home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / glisp / glisp.000 / GLISP.UNIX.TAR / closunix / clos_lf4.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-04-03  |  12.9 KB  |  480 lines
  1. /*                 GRAPHIC LISP            */
  2. /*        Scritto nel 1991-94 da Zoia Andrea Michele     */
  3. /*        Via Pergola #1 Tirano (SO) Tel. 0342-704210    */
  4. /* file clos_lf4.c */
  5.  
  6. #include "clos.h"
  7.  
  8. char *str2up();
  9.  
  10. /************ Manipolazione Stringhe **************/
  11. /* STR2REAL , STR2INT , STR2NAME , STRING-EQUAL   */
  12. /* STRING-EQ, STRINGP , STRCAT   , STRSUB      */
  13. /* STR2ASCII, STRNUM  , STRLEN     , STRPRINTF      */
  14. /**************************************************/
  15.  
  16. /* sintassi (STR2REAL <stringa>)              */
  17. /* ritorna un reale oppure il simbolo *SYNTAX_ERROR* */
  18. void lf_str2real LF_PARAMS
  19. {
  20.  n_real d;
  21.  char *ptr;
  22.  node n;
  23.  if(IS_CONS(nin)){
  24.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  25.    nin=CONSRIGHT(nin);
  26.    n=calc_pointer(nout);
  27.    if(IS_VALUE(n) && GET_VTYPE(n)==NT_STRING){
  28.      string_get(STRING(n),buf1);
  29.      d=strtod(buf1,&ptr);
  30.      while(*ptr==' ')ptr++; /* salta gli spazi finali */
  31.      if(*ptr==0){ /* XENIX non ha HUGE_VAL && d!=HUGE_VAL){ */
  32.        TYPE(nout->node=node_make())|=NT_IS_VALUE+NT_REAL;
  33.        REAL(nout->node)=d;
  34.        nout->type=P_ALLNODE;
  35.      }else{
  36.        nout->node=node_alloc(PARSE_ERROR_ID);
  37.        nout->type=P_ALLNODE;
  38.      }
  39.      return;
  40.    }
  41.    error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&n);
  42.  }
  43.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  44. }
  45.  
  46. /* sintassi (STR2INT <stringa> <intero base>? )          */
  47. /* ritorna un intero oppure il simbolo *SYNTAX_ERROR* */
  48. /* la base 
  49.  opzionale (default 10) e va da 2 a 32    */
  50. void lf_str2int LF_PARAMS
  51. {
  52.  n_int i;
  53.  char *ptr;
  54.  node n,nr;
  55.  int radix=10;
  56.  if(IS_CONS(nin)){
  57.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  58.    nin=CONSRIGHT(nin);
  59.    n=calc_pointer(nout);
  60.    if(IS_CONS(nin)){
  61.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  62.      nin=CONSRIGHT(nin);
  63.      nr=calc_pointer(nout);
  64.      if(IS_VALUE(nr) && GET_VTYPE(nr)==NT_INTEGER){
  65.        if(INTEGER(nr)<=32 && INTEGER(nr)>=2){
  66.      radix=(int)INTEGER(nr);
  67.        }else{
  68.      error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&n);
  69.        }
  70.      }else{
  71.        error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&n);
  72.      }
  73.    }
  74.    if(IS_VALUE(n) && GET_VTYPE(n)==NT_STRING){
  75.      string_get(STRING(n),buf1);
  76.      i=strtol(buf1,&ptr,radix);
  77.      while(*ptr==' ')ptr++; /* salta gli spazi finali */
  78.      if(*ptr==0){
  79.        TYPE(nout->node=node_make())|=NT_IS_VALUE+NT_INTEGER;
  80.        INTEGER(nout->node)=i;
  81.        nout->type=P_ALLNODE;
  82.      }else{
  83.        nout->node=node_alloc(PARSE_ERROR_ID);
  84.        nout->type=P_ALLNODE;
  85.      }
  86.      return;
  87.    }
  88.    error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&n);
  89.  }
  90.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  91. }
  92.  
  93. /* sintassi (STR2NAME <stringa>)            */
  94. /* ritorna un nome di atomo specificato da <stringa>    */
  95. /* es: (SETF (EVAL(NODE2STR "Atomo")) 10)        */
  96. void lf_str2name LF_PARAMS
  97. {
  98.  if(IS_CONS(nin)){
  99.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  100.     nin=calc_pointer(nout);
  101.     if(IS_VALUE(nin)&&GET_VTYPE(nin)==NT_STRING){
  102.     nout->node=node_alloc(string_getconv(STRING(nin),buf1));
  103.     nout->type=P_ALLNODE;
  104.     return;
  105.     }
  106.     error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  107.  }
  108.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  109. }
  110.  
  111.  
  112.  
  113. /* sintassi (STRING=  <stringa> <stringa> <stringa>* )              */
  114. /* ritorna T o NIL a seconda che le stringhe siano uguali o diverse */
  115. /* NOTA: "ab" e "aB" sono diverse per stringeq                 */
  116. void lf_stringeq LF_PARAMS
  117. {
  118.  /*  "ab" e "aB" sono diverse per stringeq */
  119.  node p1,p2;
  120.  if(IS_CONS(nin)){
  121.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  122.    p1=calc_pointer(nout);
  123.    if(GET_NTYPE(p1)==NT_IS_VALUE&&GET_VTYPE(p1)==NT_STRING){
  124.      if(IS_CONS(CONSRIGHT(nin))){
  125.        while(IS_CONS(nin=CONSRIGHT(nin))){
  126.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  127.      p2=calc_pointer(nout);
  128.      if(GET_NTYPE(p2)==NT_IS_VALUE&&GET_VTYPE(p2)==NT_STRING){
  129.        if(strcmp(string_get(STRING(p1),buf1),string_get(STRING(p2),buf2))){
  130.          nout->node=NIL;
  131.          nout->type=P_ALLNODE;
  132.          return;
  133.        }
  134.        continue;
  135.      }
  136.      error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&p2);
  137.        }
  138.        nout->type=P_ALLNODE;
  139.        nout->node=T;
  140.        return;
  141.      }
  142.      error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  143.    }
  144.    error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&p1);
  145.  }
  146.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  147. }
  148. /* sintassi (STRING=  <stringa> <stringa> <stringa>* )              */
  149. /* ritorna T o NIL a seconda che le stringhe siano uguali o diverse */
  150. /* NOTA: "ab" e "aB" sono uguali per stringeq                 */
  151. void lf_stringequal LF_PARAMS
  152. {
  153.  node p1,p2;
  154.  if(IS_CONS(nin)){
  155.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  156.    p1=calc_pointer(nout);
  157.    if(GET_NTYPE(p1)==NT_IS_VALUE&&GET_VTYPE(p1)==NT_STRING){
  158.      if(IS_CONS(CONSRIGHT(nin))){
  159.        while(IS_CONS(nin=CONSRIGHT(nin))){
  160.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  161.      p2=calc_pointer(nout);
  162.      if(GET_NTYPE(p2)==NT_IS_VALUE&&GET_VTYPE(p2)==NT_STRING){
  163.        if(strcmp(
  164.         str2up(string_get(STRING(p1),buf1)),
  165.         str2up(string_get(STRING(p2),buf2)))){
  166.          nout->node=NIL;
  167.          nout->type=P_ALLNODE;
  168.          return;
  169.        }
  170.        continue;
  171.      }
  172.      error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&p2);
  173.        }
  174.        nout->type=P_ALLNODE;
  175.        nout->node=T;
  176.        return;
  177.      }
  178.      error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  179.    }
  180.    error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&p1);
  181.  }
  182.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  183. }
  184.  
  185. char *str2up(s)
  186. char *s;
  187. {
  188.  char *c=s;
  189.  do
  190.    if(*s>='a' && *s<='z')
  191.      *s-=('a'-'A');
  192.  while(*s++);
  193.  return c;
  194. }
  195.  
  196. /* sintassi (STRINGP <s-espressione>)                    */
  197. /* ritorna T se s-espressione 
  198.  una stringa altrimenti ritorna NIL */
  199. void lf_stringp LF_PARAMS
  200. {
  201.  /* controlla se il nodo e' una stringa */
  202.  
  203.  if(IS_CONS(nin)){
  204.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  205.      nin=calc_pointer(nout);
  206.      nout->node=(IS_VALUE(nin)&&GET_VTYPE(nin)==NT_STRING)?T:NIL;
  207.      nout->type=P_ALLNODE;
  208.      return;
  209.  }
  210.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  211. }
  212.  
  213. /* sintassi (STRCAT <stringa>+)                        */
  214. /* ritorna una stringa concatenando tutte le <stringa> */
  215. void lf_strcat LF_PARAMS
  216. {
  217.  node n=nin;
  218.  node s;
  219.  int  flag=FALSE;
  220.  char strout[MAX_STR_LENGHT+1];
  221.  
  222.  strout[0]=0;
  223.  while(nin!=NIL){
  224.     flag=TRUE;
  225.     if(IS_CONS(nin)){
  226.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  227.     s=calc_pointer(nout);
  228.     if(IS_VALUE(s)&&GET_VTYPE(s)==NT_STRING){
  229.         string_get(STRING(s),buf1);
  230.         if(strlen(buf1)+strlen(strout)>MAX_STR_LENGHT)
  231.         error(E_STRLONG,ERR_MERROR|ERR_TBLVL|ERR_PVOID,NULL);
  232.         strcat(strout,buf1);
  233.         nin=CONSRIGHT(nin);
  234.         continue;
  235.     }
  236.     error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&s);
  237.     }
  238.     error(E_BADLIST,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&n);
  239.  }
  240.  if(flag){
  241.      nout->node=node_make();
  242.      STRING(nout->node)=string_put(strout,nout->node);
  243.      TYPE(nout->node)|=NT_IS_VALUE+NT_STRING;
  244.      /* NB: quando si alloca una stringa puo' avvenire un GC */
  245.      /* e se si assegna prima il tipo al nodo appena allocato */
  246.      /* il GC trova un nodo-stringa ma effettivamente senza la stringa */
  247.      /* creando un errore interno */
  248.      nout->type=P_ALLNODE;
  249.      return;
  250.  }
  251.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&NIL);
  252. }
  253.  
  254. /* sintassi (STRSUB <stringa> <intero-da_dove> <intero-lughezza> )                        */
  255. /* ritorna una stringa es:<(STRSUB "ABCDE" 2 3)>="BCD" */
  256. void lf_strsub LF_PARAMS
  257. {
  258.  node n=nin;
  259.  node s;
  260.  n_int from;
  261.  n_int len;
  262.  char strout[MAX_STR_LENGHT+1];
  263.  
  264.  
  265.  if(IS_CONS(nin)){
  266.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  267.    s=calc_pointer(nout);
  268.    nin=CONSRIGHT(nin);
  269.    if(IS_VALUE(s)&&GET_VTYPE(s)==NT_STRING){
  270.      string_get(STRING(s),strout);
  271.      if(IS_CONS(nin)){
  272.        eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  273.        s=calc_pointer(nout);
  274.        nin=CONSRIGHT(nin);
  275.        if(IS_VALUE(s)&&GET_VTYPE(s)==NT_INTEGER){
  276.      from=INTEGER(s);
  277.      if(from>strlen(strout))
  278.        error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNINT,&from);
  279.      if(IS_CONS(nin)){
  280.        eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  281.        s=calc_pointer(nout);
  282.        nin=CONSRIGHT(nin);
  283.        if(IS_VALUE(s)&&GET_VTYPE(s)==NT_INTEGER){
  284.          len=INTEGER(s);
  285.          if(from+len-1>strlen(strout))
  286.            error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNINT,&len);
  287.          strout[(int)(from+len-1)]=0;
  288.          nout->node=node_make();
  289.          STRING(nout->node)=string_put(&strout[(int)(from-1)],nout->node);
  290.          TYPE(nout->node)|=NT_IS_VALUE+NT_STRING;
  291.          nout->type=P_ALLNODE;
  292.          return;
  293.        }
  294.        error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&s);
  295.      }
  296.      error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&n);
  297.        }
  298.        error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&s);
  299.      }
  300.      error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&n);
  301.    }
  302.    error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&s);
  303.  }
  304.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&n);
  305. }
  306.  
  307.  
  308. /* sintassi (STR2ASCII <stringa> )               */
  309. /* ritorna un intero che 
  310.  il codice ascii del primo carattere della stringa*/
  311. void lf_str2ascii LF_PARAMS
  312. {
  313.  node s;
  314.  if(IS_CONS(nin)){
  315.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  316.    s=calc_pointer(nout);
  317.    if(IS_VALUE(s)&&GET_VTYPE(s)==NT_STRING){
  318.      string_get(STRING(s),buf1);
  319.      nout->node=node_make();
  320.      INTEGER(nout->node)=buf1[0];
  321.      TYPE(nout->node)|=NT_IS_VALUE+NT_INTEGER;
  322.      nout->type=P_ALLNODE;
  323.      return;
  324.    }
  325.    error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&s);
  326.  }
  327.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  328. }
  329.  
  330.  
  331.  
  332. /* sintassi (STRNUM <intero> )                                 */
  333. /* ritorna una stringa di 1 carattere ascii specificato dal parametro */
  334. void lf_strnum LF_PARAMS
  335. {
  336.  node s;
  337.  n_int i;
  338.  unsigned char strout[2];
  339.  if(IS_CONS(nin)){
  340.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  341.    s=calc_pointer(nout);
  342.    if(IS_VALUE(s)&&GET_VTYPE(s)==NT_INTEGER){
  343.      i=INTEGER(s);
  344.      if(i>=0 && i<=255){
  345.        strout[0]=(unsigned char)i;
  346.        strout[1]=0;
  347.        nout->node=node_make();
  348.        STRING(nout->node)=string_put(strout,nout->node);
  349.        TYPE(nout->node)|=NT_IS_VALUE+NT_STRING;
  350.        nout->type=P_ALLNODE;
  351.        return;
  352.      }
  353.      error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNINT,&i);
  354.    }
  355.    error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&s);
  356.  }
  357.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  358. }
  359.  
  360. /* sintassi (STRLEN <stringa> )       */
  361. /* ritorna un intero che 
  362.  il codice ascii del primo carattere della stringa*/
  363. void lf_strlen LF_PARAMS
  364. {
  365.  node s;
  366.  if(IS_CONS(nin)){
  367.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  368.    s=calc_pointer(nout);
  369.    if(IS_VALUE(s)&&GET_VTYPE(s)==NT_STRING){
  370.      string_get(STRING(s),buf1);
  371.      nout->node=node_make();
  372.      INTEGER(nout->node)=strlen(buf1);
  373.      TYPE(nout->node)|=NT_IS_VALUE+NT_INTEGER;
  374.      nout->type=P_ALLNODE;
  375.      return;
  376.    }
  377.    error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&s);
  378.  }
  379.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  380. }
  381.  
  382. void lf_strprintf LF_PARAMS
  383. {
  384.  /* sintassi (strprintf <string> <sx>* ) */
  385.  /* funziona esattamente come la printf delle librerie c */
  386.  /* tipi di nodo lisp      indicatore nella stringa      */
  387.  /* VALUE:                                               */
  388.  /*   INTEGER                %ld    %lx %l         */
  389.  /*   REAL                %lf             */
  390.  /*   STRING                %s             */
  391.  /*   RATIO                %lf             */
  392.  /*   SYSFUNC                %p             */
  393.  /*   CHAR                %c             */
  394.  /*   STREAM                %p             */
  395.  /*   altri               ERRORE         */
  396.  /* NAME:                         */
  397.  /*   nodo                %s             */
  398.  /* CONS:                                                */
  399.  /*   nodo               ERRORE         */
  400.   
  401.  node ni=nin;
  402.  char arr[100];
  403.  int arrc=0;
  404.  node n;
  405.  
  406.  nin=eval_list(nin,genv,lenv);
  407.  if(IS_CONS(nin)){
  408.    n=CONSLEFT(nin);
  409.    if(IS_VALUE(n) && GET_VTYPE(n)==NT_STRING){
  410.      string_getconv(STRING(n),buf1);
  411.      nin=CONSRIGHT(nin);
  412.      while(IS_CONS(nin)){
  413.        n=CONSLEFT(nin);
  414.        if(IS_CONS(n))error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&n);
  415.        if(IS_NAME(n)){
  416.      *(str_t*)(&arr[arrc])=NAME(n);
  417.      arrc+=sizeof(str_t);
  418.        }else{
  419.        switch(GET_VTYPE(n)){
  420.  
  421.      case NT_INTEGER:
  422.        *(n_int*)(&arr[arrc])=INTEGER(n);
  423.        arrc+=sizeof(n_int);
  424.        break;
  425.  
  426.      case NT_REAL:
  427.        *(n_real*)(&arr[arrc])=REAL(n);
  428.        arrc+=sizeof(n_real);
  429.        break;
  430.  
  431.      case NT_STRING:
  432.        *(str_t*)(&arr[arrc])=STRING(n);
  433.        arrc+=sizeof(str_t);
  434.        break;
  435.  
  436.      case NT_RATIO:
  437.        *(n_real*)(&arr[arrc])=(n_real)RATIO_NUM(n)/(n_real)RATIO_DEN(n);
  438.        arrc+=sizeof(n_real);
  439.        break;
  440.  
  441.      case NT_SYSFUNC:
  442.        *(n_func*)(&arr[arrc])=SYSFUNC(n);
  443.        arrc+=sizeof(n_func);
  444.        break;
  445.  
  446.      case NT_CHAR:
  447.        *(n_char*)(&arr[arrc])=CHARACTER(n);
  448.        arrc+=2*sizeof(n_char);
  449.        break;
  450.  
  451.      case NT_STREAM:
  452.        *(FILE**)(&arr[arrc])=STREAM(n);
  453.        arrc+=sizeof(FILE*);
  454.        break;
  455.  
  456. case NT_UFUNC:
  457. case NT_ACCESSOR:
  458. case NT_METHOD:
  459. case NT_CLASS:
  460. case NT_ENAME:
  461. case NT_CNAME:
  462. case NT_COMPLEX:
  463.   error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&n);
  464.  
  465.        }}
  466.        if(arrc>90)error(E_TOOMANYARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&ni);
  467.        nin=CONSRIGHT(nin);
  468.      }
  469.      vsprintf(buf2,buf1,arr);
  470.      nout->node=node_make();
  471.      STRING(nout->node)=string_put(buf2,nout->node);
  472.      TYPE(nout->node)|=NT_IS_VALUE+NT_STRING;
  473.      nout->type=P_ALLNODE;
  474.      return;
  475.     }
  476.     error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&n);
  477.    }
  478.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&ni);
  479. }
  480.